home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / boxer / boxer.lha / parse2.lisp < prev    next >
Encoding:
Text File  |  1993-07-17  |  22.1 KB  |  669 lines
  1. ;; -*- Fonts: CPTFONT;  Mode:Lisp;  Package: BOXER -*-
  2.  
  3. ;;; (C) Copyright 1985 Massachusetts Institute of Technology
  4. ;;;
  5. ;;; Permission to use, copy, modify, distribute, and sell this software
  6. ;;; and its documentation for any purpose is hereby granted without fee,
  7. ;;; provided that the above copyright notice appear in all copies and that
  8. ;;; both that copyright notice and this permission notice appear in
  9. ;;; supporting documentation, and that the name of M.I.T. not be used in
  10. ;;; advertising or publicity pertaining to distribution of the software
  11. ;;; without specific, written prior permission.  M.I.T. makes no
  12. ;;; representations about the suitability of this software for any
  13. ;;; purpose.  It is provided "as is" without express or implied warranty.
  14. ;;;
  15. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  16. ;;;                                         ;;;
  17. ;;; A "Pratt Parser" for BOXER, by Leigh Klotz. (KLOTZ@MIT-MC)        ;;;
  18. ;;; Modeled after the VAX NIL parser, by George Carrette (GJC@MIT-MC)    ;;;
  19. ;;;                                                                      ;;;
  20. ;;;    Based on a theory of parsing presented in:                       ;;;
  21. ;;;                                                                      ;;;
  22. ;;;        Pratt, Vaughan R., ``Top Down Operator Precedence,''         ;;;
  23. ;;;        ACM Symposium on Principles of Programming Languages         ;;;
  24. ;;;        Boston, MA; October, 1973.                                   ;;;
  25. ;;;                                                                      ;;;
  26. ;;; The PARSE function takes a list describing BOXER code, and returns   ;;;
  27. ;;; a list suitable for EVAL.                                            ;;;
  28. ;;; Two optional arguments specify symbols that should be considered     ;;;
  29. ;;; variables or procedures, but are not currently bound to the proper   ;;;
  30. ;;; object.                                                              ;;;
  31. ;;;                                                                      ;;;
  32. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  33.  
  34.  
  35. ;;;Special variables for the token stuff.
  36. ;Has to be a symbol so we can put a rbp property on it.
  37. ;It has to be in the boxer package to keep from confusing it
  38. ;with something in the bu package.
  39. (DEFCONST *END-OF-LINE* '*END-OF-LINE*)
  40.  
  41. (DEFVAR *CURRENT-TOKEN*)
  42. (DEFVAR *PRATT-PEEK-TOKEN?*)
  43. (DEFVAR *PRATT-READ-LIST*)
  44. (DEFVAR *TOKEN-TYPE*)
  45.  
  46. (DEFVAR *OP*)
  47. (DEFVAR *SYMBOLS-TO-BE-CONSIDERED-VARIABLES-IN-PARSING*)
  48. (DEFVAR *SYMBOLS-TO-BE-CONSIDERED-PROCEDURES-IN-PARSING*)
  49. (DEFVAR *SYMBOLS-IN-ARGLIST*)
  50.  
  51. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  52. ;;;
  53. ;;; Low-Level and setup stuff.
  54. ;;;
  55.  
  56. (DEFSUBST COERCE-NUMBER-TO-BOX (NUMBER)
  57.   (MAKE-INSTANCE 'DATA-BOX ':FIRST-INFERIOR-ROW (MAKE-ROW (NCONS NUMBER))))
  58.  
  59. ;The functions for getting the tokens from the input list, one-at-a-time.
  60. (DEFUN READ-TOKEN ()
  61.   (IF *PRATT-READ-LIST*
  62.       (SETQ *CURRENT-TOKEN* (POP *PRATT-READ-LIST*))
  63.       (SETQ *CURRENT-TOKEN* *END-OF-LINE*))
  64.   ;; get rid of number here for now (probably the wrong place to do it)
  65.   (WHEN (NUMBERP *CURRENT-TOKEN*)
  66.     (SETQ *CURRENT-TOKEN* (COERCE-NUMBER-TO-BOX *CURRENT-TOKEN*)))
  67.  
  68.   *CURRENT-TOKEN*)
  69.  
  70.  
  71. (DEFUN PRATT-READ-REST-OF-LINE ()
  72.   (IF *PRATT-PEEK-TOKEN?*
  73.       (CONS *CURRENT-TOKEN*
  74.         (PROG1 *PRATT-READ-LIST*
  75.            (SETQ *PRATT-READ-LIST* NIL
  76.              *PRATT-PEEK-TOKEN?* NIL)))
  77.       (PROG1 *PRATT-READ-LIST*
  78.          (SETQ *PRATT-READ-LIST* NIL))))
  79.  
  80. (DEFUN PRATT-PEEK-TOKEN ()
  81.   (IF *PRATT-PEEK-TOKEN?*
  82.       *CURRENT-TOKEN*
  83.       (SETQ *PRATT-PEEK-TOKEN?* T)
  84.       (READ-TOKEN)))
  85.  
  86. (DEFUN PRATT-READ-TOKEN ()
  87.   (COND (*PRATT-PEEK-TOKEN?*
  88.      (SETQ *PRATT-PEEK-TOKEN?* NIL)
  89.      *CURRENT-TOKEN*)
  90.     (T (READ-TOKEN))))
  91.  
  92. (DEFUN PRATT-READ-TOKEN-NO-EOL ()
  93.   (LET ((RESULT (PRATT-READ-TOKEN)))
  94.     (IF (EQ RESULT *END-OF-LINE*)
  95.     (PARSER-BARF "Not enough stuff on line.")
  96.     RESULT)))
  97.  
  98.  
  99. ;;; Code generators.
  100.  
  101. ;This reminds me of writing APPLY in Logo.
  102. (defun ENSHROUD-BOX-OR-VARIABLE (it)
  103.   (cond ((box? it) (list 'quote it))
  104.     ((symbolp it) (boxer-variable-reference it))
  105.     (t it)))
  106.  
  107. (defun boxer-variable-reference (symbol)
  108.   `(boxer-symeval ',symbol))
  109.  
  110. (defun extract-entry (thing)
  111.   (if (label-pair? thing) (label-pair-element thing) thing))
  112.  
  113. (defun parser-token-type (lex)
  114.   (cond ((label-pair? lex) 'LABEL-PAIR)
  115.     ((numberp lex) 'NUMBER)
  116.     ((access-pair? lex) 'ACCESS-PAIR)
  117.     (t (or (cdr (assq (typep lex)
  118.               '((:symbol . symbol)
  119.                 (:string . string)
  120.                 (data-box . data-box)
  121.                 (port-box . port-box)
  122.                 (doit-box . doit-box)
  123.                 (sprite-box . sprite-box)
  124.                 (GRAPHICS-BOX . GRAPHICS-BOX)
  125.                 (GRAPHICS-data-BOX . GRAPHICS-data-BOX))))
  126.            (ferror nil "~S -- Unknown type in parser." lex)))))
  127.  
  128.  
  129. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  130. ;;;
  131. ;;; The top-level parsing function.  Given a list describing a boxer expression,
  132. ;;; it returns a list suitable for EVAL.  The caller should take this list
  133. ;;; and do one of several things, like eval it, wrap a lambda around it,
  134. ;;; or glom it together with some other ones in a PROGN.
  135. ;;;
  136. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  137.  
  138. (defun parse (exp &optional (variables nil) (procedures nil) (inputs nil))
  139.   (if (null exp) nil
  140.       (let ((*pratt-read-list* (SUBSET-NOT #'NAMED-BOX-P exp))
  141.         (*current-token*)
  142.         (*PRATT-PEEK-TOKEN?*)
  143.         (*OP* "Something")          ;crock for now...
  144.         (*SYMBOLS-TO-BE-CONSIDERED-VARIABLES-IN-PARSING* variables)
  145.         (*SYMBOLS-TO-BE-CONSIDERED-PROCEDURES-IN-PARSING* procedures)
  146.         (*SYMBOLS-IN-ARGLIST* inputs))
  147.     (pratt-parse 0))))
  148.  
  149. ;;; NUD -- NUll left Denotation (op has nothing to its left (prefix))
  150. ;;; LED -- LEft Denotation    (op has something to left (postfix or infix))
  151. ;;;
  152. ;;; LBP -- Left Binding Power  (the stickiness to the left)
  153. ;;; RBP -- Right Binding Power (the stickiness to the right)
  154.  
  155. ;;; (PRATT-PARSE <rbp>)
  156. ;;;
  157. ;;;  This will parse an expression containing operators which have a higher
  158. ;;;  left binding power than <rbp>, returning as soon as an operator of
  159. ;;;  lesser or equal binding power is seen.
  160.  
  161. ;note that the error reporting depends on the special variable *OP*...
  162. (DEFUN PRATT-PARSE (RBP)
  163.   (LET ((RESULT (PRATT-PARSE-ALLOW-EOL RBP)))
  164.     (IF (EQ RESULT *END-OF-LINE*) (PARSER-BARF "~A needs more inputs." *OP*)
  165.     RESULT)))
  166.  
  167. (DEFUN PRATT-PARSE-ALLOW-EOL (RBP)
  168.   (DO ((EXPRESSION (PRATT-NUD-CALL (PRATT-READ-TOKEN) (parser-token-type *current-token*))
  169.            (PRATT-LED-CALL (PRATT-READ-TOKEN) (parser-token-type *current-token*)
  170.                    EXPRESSION)))
  171.       ((>= RBP (PRATT-LBP (PRATT-PEEK-TOKEN) (parser-token-type (pratt-peek-token))))
  172.        EXPRESSION)))
  173.  
  174. (DEFUN PRATT-NUD-CALL (LEX TYP)
  175.   (funcall (OR (get typ 'NUD-TYPE-HANDLER)
  176.            #'(LAMBDA (U) (FERROR "~S unknown datatype in parsing." U)))
  177.        LEX))
  178.  
  179. (DEFUN PRATT-LED-CALL (LEX TYP EXP)
  180.   (LET ((F (AND (EQ TYP 'SYMBOL) (GET LEX 'LED))))
  181.     (IF F (FUNCALL F LEX EXP)
  182.     (if (eq (car exp) 'boxer-symeval)
  183.         (PARSER-BARF "/~A/ is not a defined procedure."
  184.              (cadr (cadr exp)))    ;extracts variable reference. crock.
  185.         (parser-barf "Too many commands on one line, just before ~A" lex)
  186. ;;          (parser-barf "/"~A/" is not an infix operator." lex)
  187.         ))))
  188.  
  189.  
  190. ;If a function has no precedence, then it's assumed to be less than
  191. ;the lowest infix function.
  192. (DEFUN PRATT-BP (LEX TYP P)
  193.   (or (and (eq typ 'symbol)
  194.        (get lex p))
  195.       50))
  196.   
  197. (DEFUN PRATT-LBP (LEX &OPTIONAL (TYP 'SYMBOL))
  198.     (PRATT-BP LEX TYP 'LBP))
  199.   
  200. (DEFUN PRATT-RBP (LEX &OPTIONAL (TYP 'SYMBOL))
  201.     (PRATT-BP LEX TYP 'RBP))
  202.   
  203. (defun end-of-line-fun (*op*)
  204.   *op*)
  205.  
  206. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  207. ;;;
  208. ;;; Things for dealing with different funny datatypes in the prefix position.
  209. ;;; Funcalled by PRATT-NUD-CALL.
  210. ;;;
  211. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  212.   
  213.   
  214. ;;;This function is nonstandard, in that it understands what to
  215. ;;;do with special boxer datatypes.  If the symbol is on the
  216. ;;;lambda-list of the currently-being-parsed box, then it is not
  217. ;;;special and is a variable.
  218. ;;;
  219. ;;;Otherwise, If the token is a sumbol and it has a NUD
  220. ;;;property, then this NUD property is funcalled with the
  221. ;;;current-token as input.  That's for parsing infix and special
  222. ;;;forms.
  223. (DEFUN (:PROPERTY SYMBOL NUD-TYPE-HANDLER) (LEX)
  224.   (LET ((PARSING-FUN (GET LEX 'NUD))    ;Special form property.
  225.     (NARGS (PARSER-PROCEDURE-SYMBOL-DESCRIPTOR-NUMBER-OF-ARGS
  226.          (ASSQ LEX *SYMBOLS-TO-BE-CONSIDERED-PROCEDURES-IN-PARSING*))))
  227.     (COND ((OR (MEMQ LEX *SYMBOLS-IN-ARGLIST*)
  228.            (ASSQ LEX *SYMBOLS-TO-BE-CONSIDERED-VARIABLES-IN-PARSING*))
  229.        (BOXER-VARIABLE-REFERENCE LEX))     ;It's definitely a varible.
  230.       ((NUMBERP NARGS) (PRATT-PARSE-MULTIPREFIX LEX NARGS))    ;It's certainly a function.
  231.       (parsing-fun (FUNCALL parsing-fun LEX))    ;Special form
  232.       ((BOXER-FDEFINED? LEX)         ;It's a currently-defined function
  233.        (PRATT-PARSE-MULTIPREFIX LEX (PARSER-NUMBER-OF-ARGS LEX)))
  234.       ((sprite-box? (boxer-symeval lex))
  235.        (list 'quote (port-to-internal (boxer-symeval lex))))
  236.       (T (BOXER-VARIABLE-REFERENCE LEX)))))  ;Must be a variable or undefined function
  237.  
  238. ;;;If it's a data-box, then it parses into 'BOX.  Self-evaling
  239. ;;;things (numbers, strings) parse into themseves.  Other things
  240. ;;;are probably broken anyway.
  241. ;;;
  242. ;;;Things which are currently-defined functions are parsed as
  243. ;;;multiple-input prefix functions according to the number of
  244. ;;;inputs they have.
  245.  
  246. (DEFUN (:PROPERTY NUMBER NUD-TYPE-HANDLER) (LEX)
  247.   LEX)
  248.  
  249. (DEFUN (:PROPERTY STRING NUD-TYPE-HANDLER) (LEX)
  250.   LEX)
  251.  
  252. (DEFUN (:PROPERTY GRAPHICS-BOX NUD-TYPE-HANDLER) (LEX)
  253.   (LIST 'QUOTE LEX))
  254.  
  255. (DEFUN (:PROPERTY DATA-BOX NUD-TYPE-HANDLER) (LEX)
  256.  (LIST 'QUOTE LEX))
  257.  
  258. (DEFUN (:PROPERTY graphics-DATA-BOX NUD-TYPE-HANDLER) (LEX)
  259.  (LIST 'QUOTE LEX))
  260.  
  261. (defun (:property sprite-box nud-type-handler) (lex)
  262.   (list 'quote (port-to-internal lex)))
  263.  
  264. (DEFUN (:PROPERTY DOIT-BOX NUD-TYPE-HANDLER) (LEX)
  265.   (PRATT-PARSE-MULTIPREFIX LEX (PARSER-NUMBER-OF-ARGS LEX)))
  266.  
  267. (defun (:property port-box nud-type-handler) (lex)
  268.   (let ((obj (tell lex :ports)))
  269.     (cond ((data-box? obj) (list 'quote lex))
  270.       ((doit-box? obj) (pratt-parse-multiprefix lex (parser-number-of-args obj)))
  271.       ((GRAPHICS-BOX? OBJ) (list 'quote lex))
  272.       ((sprite-box? obj) (list 'quote obj))
  273.       ((graphics-data-box? obj) (list 'quote lex))
  274.       (t (ferror "Tried to parse a reference to a port which wasn't a port to a doit
  275. or data box: ~S" lex)))))
  276.  
  277. (DEFUN (:PROPERTY LABEL-PAIR NUD-TYPE-HANDLER) (LEX)
  278.  (PRATT-NUD-CALL (LABEL-PAIR-ELEMENT LEX)
  279.          (PARSER-TOKEN-TYPE (LABEL-PAIR-ELEMENT LEX))))
  280.  
  281. ;This is a crock.  These things shouldn't be put in procedure lambdas,
  282. ;but should be parsed when doit'd explcitly.  There's no way to tell,
  283. ;though.  We really need some other way of doing initial variable assignment.
  284. ;(defun (:property NAME-PAIR NUD-TYPE-HANDLER) (lex)
  285. ;  (let ((name (name-pair-name lex))
  286. ;    (val (name-pair-element lex)))
  287. ;    (if (box? val) (tell val :set-name name))
  288. ;    `(PROGN
  289. ;       (BOXER-MAKE ',name
  290. ;           ',val)
  291. ;       ':NOPRINT)))
  292.  
  293.  
  294.  
  295. ;;And if you think THAT was a crock...
  296.  
  297. ;(defun (:property ACCESS-PAIR NUD-TYPE-HANDLER)(lex)
  298. ;  (let* ((superbox (access-pair-superbox lex))
  299. ;     (subbox (access-pair-subbox lex)))
  300. ;    `(progn 
  301. ;       (boxer-tell (boxer-eval ',superbox)
  302. ;           (let ((eval-subbox (caar (get-pre-box-rows (boxer-eval ',subbox)))))
  303. ;             `(,eval-subbox))))))
  304.  
  305.  
  306.  
  307. ;;; Parsing functions for various pieces of syntax.
  308.  
  309.  
  310. ;;; (PRATT-PARSE-MULTIPREFIX <*OP*> <nargs>)
  311. ;;; Parses prefix forms with multiple args -- e.g, REMAINDER 2 3
  312. ;;;
  313. ;;; This is the default parsing property for symbols.  It fires after any
  314. ;;; symbol currently defined as a function has been seen.  It parses
  315. ;;; forward looking for NARGS more expressions according to its right binding
  316. ;;; power, returning a proper boxer-funcall expression.
  317.  
  318. (defun pratt-parse-multiprefix (*OP* nargs)
  319.   (LIST* 'BOXER-FUNCALL
  320.      (ENSHROUD-BOX-OR-VARIABLE *OP*)
  321.     ;; Get nargs args.
  322.     (let ((rbp (PRATT-RBP *OP*)))
  323.       (do ((args nil (cons (LET ((IT (PRATT-PARSE rbp)))
  324.                  (IF (EQ *END-OF-LINE* IT)
  325.                      (PARSER-BARF "~A needs more inputs." *OP*)
  326.                      (ENSHROUD-BOX-OR-VARIABLE it)))
  327.                    args))
  328.            (nargs nargs (1- nargs)))
  329.           ((zerop nargs) (nreverse args))))))
  330.  
  331.  
  332. ;;; (PRATT-PARSE-PREFIX <*OP*>)
  333. ;;;
  334. ;;;  Parses prefix forms -- eg, - X or + X.
  335. ;;;
  336. ;;;  This should be the NUD property on an operator. It fires after <op>
  337. ;;;  has been seen. It parses forward looking for one more expression
  338. ;;;  according to its right binding power, returning (<*OP*> <arg1>).
  339.  
  340. (DEFUN PRATT-PARSE-PREFIX (*OP*)
  341.   (LIST 'BOXER-FUNCALL
  342.     (ENSHROUD-BOX-OR-VARIABLE *OP*)
  343.     ;; Convert single argument for use
  344.     (ENSHROUD-BOX-OR-VARIABLE (PRATT-PARSE (PRATT-RBP *OP*)))))
  345.  
  346.  
  347. ;;; (PRATT-PARSE-POSTFIX <*OP*> <left>)
  348. ;;;
  349. ;;;  Parses postfix forms. eg, X !.
  350. ;;;
  351. ;;;  This should be the LED property of an operator. It fires after <left>
  352. ;;;  has been accumulated and <op> has been seen and gobbled up. It returns
  353. ;;;  (<*OP*> <arg1>).
  354.  
  355. (DEFUN PRATT-PARSE-POSTFIX (*OP* left)
  356.   (LIST
  357.     'BOXER-FUNCALL
  358.     (ENSHROUD-BOX-OR-VARIABLE *OP*)
  359.     left))
  360.  
  361. ;;; (PRATT-PARSE-INFIX <*OP*> <left>)
  362. ;;;
  363. ;;;  Parses infix (non-nary) forms. eg, 5 mod 3.
  364. ;;;  For things like +, see PRATT-PARSE-NARY.
  365. ;;;
  366. ;;;  This should be the led property of an operator. It fires after <left>
  367. ;;;  has been accumulated and <*OP*> has been seen and gobbled up.
  368.  
  369. (DEFUN PRATT-PARSE-INFIX (*OP* arg1)
  370.   (LIST
  371.    'BOXER-FUNCALL
  372.     *OP*
  373.     ARG1
  374.     ;; Look for an arg2 
  375.     (ENSHROUD-BOX-OR-VARIABLE (PRATT-PARSE (PRATT-RBP *OP*)))))
  376.  
  377. ;;; (PRATT-PARSE-NARY <*OP*> <left>)
  378. ;;;
  379. ;;;  Parses nary forms. Eg, form1*form2*... or form1+form2+...
  380. ;;;  This should be the LED property on an operator. It fires after <op>
  381. ;;;  has been seen, accumulating and returning
  382. ;;;  (<*OP*> <arg1> <arg2> ...).
  383. ;;;
  384. ;;;  <*OP*>   is the being parsed.
  385. ;;;  <left> is the stuff that has been seen to the left of <*OP*> which 
  386. ;;;         rightly belongs to <*OP*> on the basis of parse precedence rules.
  387.  
  388. (DEFUN PRATT-PARSE-NARY (*OP* L)
  389.   (LIST* 'BOXER-FUNCALL
  390.      *OP*
  391.      (ENSHROUD-BOX-OR-VARIABLE L)
  392.      ;; Search for other args
  393.      (PRATT-PARSE-NARY-SUB *OP* (PRATT-LBP *OP*))))
  394.  
  395. ;;; (PRATT-PARSE-NARY-SUB <*OP*> <rbp>)
  396. ;;;
  397. ;;;  Parses an nary operator tail E.G., ...form2+form3+... or ...form2*form3*..
  398. ;;;
  399. ;;;  Expects to be entered after the leading form and the first call to an 
  400. ;;;  nary operator has been seen and popped. Returns a list of parsed forms
  401. ;;;  which belong to that operator. Eg, for X+Y+Z; this should be called 
  402. ;;;  after the first + is popped. Returns (Y Z).
  403. ;;;
  404. ;;;  <*OP*>   is the nary operator in question.
  405. ;;;  <rbp>  is (LBP <*OP*>) and is provided for efficiency. It is for use in
  406. ;;;         recursive parses as a binding power to parse for.
  407.  
  408. (DEFUN PRATT-PARSE-NARY-SUB (*OP* RBP)
  409.   (DO ((NL (LIST (PRATT-PARSE RBP))       ;Get at least one form
  410.        (CONS (PRATT-PARSE RBP) NL)))   ;and keep getting forms
  411.       ((NOT (EQ *OP* (PRATT-PEEK-TOKEN)))  ;until a parse pops on a new op
  412.        (NREVERSE NL))               ;at which time return forms
  413.       (PRATT-READ-TOKEN)))                 ;otherwise pop *OP*
  414.  
  415.  
  416. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  417. ;;; Boxer Special Form parser
  418. ;;; It's like DEFUN, but the special arg declarations are in lists instead
  419. ;;; of being flattened out -- for example:
  420. ;;; (defboxer-macro set (("e variable) value)
  421. ;;;   `(progn
  422. ;;;      (boxer-set ',variable ,value)
  423. ;;;      ':NOPRINT))
  424. ;;; There are subtlties about "e and also about whether you put a quote before
  425. ;;; a comma.
  426.  
  427. (defmacro defboxer-special (name arglist &body body)
  428.   (let* ((argnames (mapcar #'(lambda (entry)
  429.                    (if (symbolp entry)
  430.                    entry
  431.                    (cadr entry)))
  432.                arglist))
  433.      (bu-name (intern-in-bu-package name))
  434.      (values (mapcar #'(lambda (entry)
  435.                (if (symbolp entry)
  436.                    '(pratt-parse (pratt-rbp *OP*))
  437.                    (selectq (car entry)
  438.                  ("e  '(extract-entry (pratt-read-token-no-eol)))
  439.                  (&rest '(pratt-read-rest-of-line))
  440.                  (otherwise (ferror
  441.                           "Bad arglist element in DEFBOXER-SPECIAL ~S"
  442.                           entry)))))
  443.                arglist)))
  444.     `(progn 'compile
  445.         (putprop ',bu-name ',argnames 'arglist)
  446.         (defun (:property ,bu-name nud) (*op*)
  447.           (let ,(mapcar #'list argnames values)
  448.         .,body)))))
  449.  
  450.  
  451.  
  452. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  453. ;;;
  454. ;;; Parsers for special forms.
  455. ;;; These functions are on the Null Left Denotation property of the function
  456. ;;; name.  They get one argument, which is the name of the function (for
  457. ;;; functions that want to handle multiple ones.)  They should return some
  458. ;;; eval-able lisp code.
  459. ;;;
  460. ;;; This stuff should be replaced with a macro that takes a function name
  461. ;;; and an arglist and does the right thing.
  462.  
  463.  
  464. ;;;REPEAT 3 <box or form>
  465.  
  466. (defboxer-special repeat (times stuff)
  467.   `(catch 'iteration-tag
  468.      (dotimes (repeat-times (NUMBERIZE ,TIMES))
  469.        ,stuff)))
  470.  
  471.  
  472. ;;;IF BOX BOX
  473. ;;;IF BOX BOX BOX
  474.  
  475. (defprop bu:if (PREDICATE CONSEQUENT ALTERNATIVE) ARGLIST)
  476. (defun (:property BU:IF nud) (*OP*)
  477.   (let ((predicate (pratt-parse (pratt-rbp *OP*)))
  478.     (consequent (pratt-parse (pratt-rbp *OP*))))
  479.     (if (eq (pratt-peek-token) *end-of-line*)
  480.     `(COND ((TRUE? ,predicate) ,consequent))
  481.     `(COND ((TRUE? ,predicate) ,consequent)
  482.            (t ,(pratt-parse (pratt-rbp *OP*)))))))
  483.  
  484.  
  485. ;;;TELL BOX DOITBOX
  486. ;;;=> (boxer-tell 'box '(list of elements on rest of line))
  487. ;;;or (boxer-tell-rowlist 'box '(list of rows))
  488. ;this parsing isn't quite right
  489. (defboxer-special tell (who (&rest what))
  490.     (if (and (null (cdr what))
  491.          (doit-box? (car what)))
  492.     `(boxer-tell-rowlist ,who
  493.              ',(tell (car what) :rows))
  494.     `(boxer-tell ,who ',what)))
  495.  
  496. ;;;; A real quick one here 
  497.  
  498. (defboxer-special tell-all (whos (&rest what))
  499.   (if (and (null (cdr what))
  500.        (doit-box? (car what)))
  501.       `(loop for box in (subset #'box? (tell ,whos :elements))
  502.          do (boxer-tell-rowlist box ',(tell (car what) :rows)))
  503.       `(loop for box in (subset #'box? (tell ,whos :elements))
  504.          do (boxer-tell box ',what))))
  505.  
  506. ;;;DEFINE-INSIDE-BOX
  507. ;; Actually, TELL should take care of this special form, but for reasons that
  508. ;; are momentarily unclear, it doesn't. This procedure allows you to create
  509. ;; a binding inside another box, as in 
  510. ;; DEFINE-INSIDE-BOX FOO NEW-FOO-PROC <doit-box>.
  511. ;; Perhaps the result of such a call should be that the new binding is actually
  512. ;; displayed somewhere inside FOO (as in, at least, the local library of FOO).
  513. ;; Right now, this doesn't happen -- so use this at your own risk.
  514. (defboxer-special define-inside-box (box ("e name)("e value))
  515.   `(tell ,box :add-static-variable-pair ',name ',value))
  516.  
  517. ;;;SET x 3
  518. ;;;SET does searching.
  519. (defboxer-special set (("e variable) value)
  520.   `(progn
  521.      (boxer-set ',variable ,value)
  522.      ':NOPRINT))
  523.  
  524.  
  525. ;;;MAKE X box
  526. ;;;Make always affects the current box environment.  If there's no variable
  527. ;;;named X, it adds one.  If there's nothing running (i.e. toplevel inside
  528. ;;;a box) it adds it permanently, otherwise it adds it to the copy.
  529. (defboxer-special make (("e variable) value)
  530.   `(progn
  531.      (boxer-make ',variable
  532.          ,value)
  533.      ':noprint))
  534.  
  535. ;;;FILE is like MAKE, but doesn't eval the second arg.
  536. ;;;FILE X box
  537. (defboxer-special file (("e variable) ("e value))
  538.   `(PROGN 
  539.      (boxer-make ',variable
  540.          ',value)
  541.      ':noprint))
  542.  
  543. ;;;TEXT name-or-box
  544. (defboxer-special text (("e box-or-name))
  545.   `(datafy ,(cond ((box? box-or-name)
  546.            (LIST 'QUOTE box-or-name))
  547.          ((symbolp box-or-name)
  548.           (LIST 'QUOTE (BOXER-SYMEVAL box-or-name)))
  549.          (t (parser-barf "TEXT doesn't like ~A as input.  It expects a doit-box or the name of a doit-box." box-or-name)))))
  550.  
  551. ;;; STOP
  552. ;;; This isn't quite worked out yet.
  553.  
  554. (defboxer-special stop ()
  555.   `(throw 'iteration-tag ':NOPRINT))
  556.  
  557. (defboxer-special return (value)
  558.   `(throw 'iteration-tag ,value))
  559.  
  560. ;;;The Local Library might have an INPUT/INPUTS line in it, and it doesn't go through
  561. ;;;;parse-code-into-lambda which excises the inputs line before parsing the
  562. ;;;;whole thing (as a speed hack).
  563.  
  564. (defboxer-special input ((&rest ignore))
  565.   '':NOPRINT)
  566.  
  567. (defboxer-special inputs ((&rest ignore))
  568.   '':NOPRINT)
  569.  
  570. ;;Exporting variables
  571. (DEFBOXER-FUNCTION BU:SHOW-EXPORTS (BOX)
  572.   (LET ((EXPORTING-VARS (TELL BOX :GET-EXPORTS)))
  573.     (IF (NULL EXPORTING-VARS)
  574.     (MAKE-BOX ())
  575.     (MAKE-BOX (MAPCAR #'NCONS EXPORTING-VARS)))))
  576.  
  577. (DEFBOXER-FUNCTION BU:EXPORT-ALL (BOX)
  578.   (TELL BOX :EXPORT-ALL-VARIABLES))
  579.  
  580. (DEFBOXER-SPECIAL BU:EXPORT (("E VARIABLE) BOX)
  581.   `(PROGN (TELL ,BOX :EXPORT-VARIABLE ',VARIABLE) ':NOPRINT))
  582.  
  583. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  584. ;;;
  585. ;;; Setup stuff.  This function should be made readable.
  586. ;;;
  587.  
  588. (DEFUN ENTER-PRATT-OP (OP &REST P)
  589.   (LET (LBP RBP)
  590.     (do ((list p (cddr list)))
  591.     ((null list))
  592.     (LET ((K (car list))
  593.           (v (cadr list)))
  594.       (COND ((EQ K 'LBP)
  595.          (SETQ LBP V))
  596.         ((EQ K 'RBP)
  597.          (SETQ RBP V))
  598.         ('ELSE
  599.          (PUTPROP OP
  600.               (IF (AND (MEMQ K '(NUL LED))
  601.                    (SYMBOLP V))
  602.                   (FSYMEVAL V)
  603.                   V)
  604.               K)))))
  605.       (LET ((EXISTING-LBP (GET OP 'LBP))
  606.         (EXISTING-RBP (GET OP 'RBP)))
  607.        (COND ((NOT LBP)
  608.           (COMMENT IGNORE OMITTED ARG))
  609.          ((NOT EXISTING-LBP)
  610.           (SETF (GET OP 'LBP) LBP))
  611.          ((NOT (EQUAL EXISTING-LBP LBP))
  612.           (FERROR "Incompatible LBP's defined for ~S operator" OP)))
  613.        (COND ((NOT RBP)
  614.           (COMMENT IGNORE OMITTED ARG))
  615.          ((NOT EXISTING-RBP)
  616.           (SETF (GET OP 'RBP) RBP))
  617.          ((NOT (EQUAL EXISTING-RBP RBP))
  618.           (FERROR "Incompatible RBP's defined for ~S operator"
  619.              OP))))))
  620.  
  621. (EVAL-WHEN (LOAD EVAL)
  622. (MAPC #'(LAMBDA (L)
  623.       (APPLY #'ENTER-PRATT-OP L))
  624.       '((BU:|^| LED PRATT-PARSE-INFIX
  625.          LBP 140.
  626.          RBP 139.)
  627.     (BU:|*| LED PRATT-PARSE-NARY
  628.          LBP 120.)
  629.     (BU:|//| LED PRATT-PARSE-INFIX
  630.           LBP 120.
  631.           RBP 120.)
  632.     (BU:|+| NUD PRATT-PARSE-PREFIX
  633.          LBP 100.
  634.          RBP 100.
  635.          LED PRATT-PARSE-NARY)
  636.     (BU:|-| NUD PRATT-PARSE-PREFIX
  637.          LBP 100.
  638.          RBP 134.
  639.          LED PRATT-PARSE-NARY)
  640.     (BU:|=| LED PRATT-PARSE-INFIX
  641.          LBP 80.
  642.          RBP 80.)
  643.     (BU:|>| LED PRATT-PARSE-INFIX
  644.          LBP 80.
  645.          RBP 80.)
  646.     (BU:|>=| LED PRATT-PARSE-INFIX
  647.           LBP 80.
  648.           RBP 80.)
  649.     (BU:|| LED PRATT-PARSE-INFIX
  650.         LBP 80
  651.         RBP 80)
  652.     (BU:|<| LED PRATT-PARSE-INFIX
  653.          LBP 80.
  654.          RBP 80.)
  655.     (BU:|<=| LED PRATT-PARSE-INFIX
  656.           LBP 80.
  657.           RBP 80.)
  658.     (BU:|| LED PRATT-PARSE-INFIX
  659.           LBP 80.
  660.           RBP 80.)
  661.     (bu:|| LED PRATT-PARSE-INFIX
  662.           LBP 80.
  663.           RBP 80.)
  664.     (*END-OF-LINE* NUD end-of-line-fun
  665.           LBP -1)))
  666. ); End of Eval-when.
  667.  
  668.  
  669.